home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / numer.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  7.7 KB  |  280 lines

  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;     (c) Copyright 1982 Massachusetts Institute of Technology         ;;;
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (in-package "MAXIMA")
  12. (macsyma-module numer)
  13. (load-macsyma-macros numerm)
  14.  
  15. ;;; Interface of lisp numerical routines to macsyma.
  16. ;;; 4:34pm  Thursday, 28 May 1981 - George Carrette.
  17.  
  18. (DEFUN COMPATIBLE-ARRAY-TYPE? (TYPE TYPE-LIST)
  19.   #+MACLISP
  20.   (MEMQ TYPE TYPE-LIST)
  21.   #+NIL
  22.   (memq (or (cdr (assq type '((double-float . flonum))))
  23.         type)
  24.     type-list)
  25.   #+cl
  26.   (PROGN TYPE-LIST
  27.      (EQ TYPE t)
  28.      )
  29.   )
  30.  
  31. (DEFMFUN GET-ARRAY (X &OPTIONAL (KINDS NIL) (/#-DIMS) &REST DIMENSIONS)
  32. ;  "Get-Array is fairly general.
  33. ;  Examples:
  34. ;  (get-array ar '(flonum) 2 3 5) makes sure ar is a flonum array
  35. ;  with 2 dimensions, of 3 and 5.
  36. ;  (get-array ar '(fixnum) 1) gets a 1 dimensional fixnum array."
  37.   (COND ((NULL KINDS) (get-array-pointer x))
  38.     ((NULL /#-DIMS)
  39.      (LET ((A  (get-array-pointer x)))
  40.        (COND ((COMPATIBLE-ARRAY-TYPE? (ARRAY-TYPE A) KINDS) A)
  41.          (T
  42.           (MERROR "~:M is not an array of type: ~:M"
  43.               X
  44.               `((mlist) ,@kinds))))))
  45.     ((NULL DIMENSIONS)
  46.      (LET ((A (GET-ARRAY X KINDS)))
  47.        (COND ((= (ARRAY-rank A) /#-DIMS) A)
  48.          (T
  49.           (MERROR "~:M does not have ~:M dimensions." X /#-DIMS)))))
  50.     ('ELSE
  51.      (LET ((A (GET-ARRAY X KINDS /#-DIMS)))
  52.        (DO ((J 1 (f1+ J))
  53.         (L DIMENSIONS (CDR L)))
  54.            ((NULL L)
  55.         A)
  56.          (OR (OR (EQ (CAR L) '*)
  57.              (= (CAR L) (ARRAY-DIMENSION-N J A)))
  58.          (MERROR "~:M does not have dimension ~:M equal to ~:M"
  59.              X
  60.              J
  61.              (CAR L))))))))
  62.  
  63. (DECLARE-top (SPECIAL %E-VAL))
  64.  
  65. (DEFUN MTO-FLOAT (X)
  66.   (FLOAT (IF (NUMBERP X)
  67.          X
  68.          (LET (($NUMER T) ($FLOAT T))
  69.            (RESIMPLIFY (SUBST %E-VAL '$%E X))))))
  70.  
  71. ;;; Trampolines for calling with numerical efficiency.
  72.  
  73. (DEFVAR TRAMP$-ALIST ())
  74.  
  75. (DEFMACRO DEFTRAMP$ (NARGS)
  76.   (LET ((TRAMP$ (SYMBOLCONC 'TRAMP NARGS '$))
  77.     #+MACLISP
  78.     (TRAMP$-S (SYMBOLCONC 'TRAMP NARGS '$-S))
  79.     (TRAMP$-F (SYMBOLCONC 'TRAMP NARGS '$-F))
  80.     (TRAMP$-M (SYMBOLCONC 'TRAMP NARGS '$-M))
  81.     (L (MAKE-LIST NARGS)))
  82.     (LET ((ARG-LIST (MAPCAR #'(LAMBDA (IGN)IGN (GENSYM)) L))
  83.       #+MACLISP
  84.       (ARG-TYPE-LIST (MAPCAR #'(LAMBDA (IGNORE) 'flonum) L)))
  85.     `(PROGN ;'COMPILE
  86.         (PUSH '(,NARGS ,TRAMP$
  87.             #+MACLISP ,TRAMP$-S
  88.             ,TRAMP$-F ,TRAMP$-M)
  89.           TRAMP$-ALIST)
  90.         (DEFMVAR ,TRAMP$ "Contains the object to jump to if needed")
  91.         #+MACLISP
  92.         (DECLARE-top (FLONUM (,TRAMP$-S ,@ARG-TYPE-LIST)
  93.                  (,TRAMP$-F ,@ARG-TYPE-LIST)
  94.                  (,TRAMP$-M ,@ARG-TYPE-LIST)))
  95.         #+MACLISP
  96.         (DEFUN ,TRAMP$-S ,ARG-LIST
  97.           (FLOAT (SUBRCALL NIL ,TRAMP$ ,@ARG-LIST)))
  98.         (DEFUN ,TRAMP$-F ,ARG-LIST
  99.           (FLOAT (FUNCALL ,TRAMP$ ,@ARG-LIST)))
  100.         (DEFUN ,TRAMP$-M ,ARG-LIST
  101.           (FLOAT (MAPPLY1 ,TRAMP$ (LIST ,@ARG-LIST) ',TRAMP$ nil)))))))
  102.  
  103. (DEFTRAMP$ 1)
  104. (DEFTRAMP$ 2)
  105. (DEFTRAMP$ 3)
  106.  
  107. (DEFMFUN MAKE-TRAMP$ (F N)
  108.   (LET ((L (zl-ASSOC N TRAMP$-ALIST)))
  109.     (IF (NULL L)
  110.     (MERROR "BUG: No trampoline of argument length ~M" N))
  111.     (POP L)
  112.     (LET (tramp$ #+maclisp tramp$-s tramp$-s tramp$-f)
  113.      (declare (special tramp$ tramp$-s tramp$-f ))
  114.      (setq tramp$ (pop l)
  115.            #+maclisp TRAMP$-S #+maclisp (POP L)
  116.            tramp$-f (pop l)
  117.            tramp$-m (pop l))
  118.       (LET ((WHATNOT (FUNTYPEP F)))
  119.     (CASE (CAR WHATNOT)
  120.       ((OPERATORS)
  121.        (SET TRAMP$ F)
  122.        (GETSUBR! TRAMP$-M))
  123.          ((MEXPR)
  124.        (SET TRAMP$ (CADR WHATNOT))
  125.        (GETSUBR! TRAMP$-M))
  126.       #+MACLISP
  127.       ((SUBR)
  128.        (COND ((SHIT-EQ (CADR WHATNOT) (GETSUBR! TRAMP$-S))
  129.           ;; This depends on the fact that the lisp compiler
  130.           ;; always outputs the same first instruction for
  131.           ;; "flonum compiled" subrs.
  132.           (CADR WHATNOT))
  133.          ('ELSE
  134.           (SET TRAMP$ (CADR WHATNOT))
  135.           (GETSUBR! TRAMP$-S))))
  136.       ((EXPR LSUBR)
  137.        (SET TRAMP$ (CADR WHATNOT))
  138.        (GETSUBR! TRAMP$-F))
  139.       (T
  140.        (MERROR "Undefined or inscrutable function~%~M" F)))))))
  141.  
  142.  
  143. (DEFUN GETSUBR! (X)
  144.   (OR #+MACLISP(GET X 'SUBR)
  145.       #+(OR cl NIL) (AND (SYMBOLP X) (FBOUNDP X) (SYMBOL-FUNCTION X))
  146.       (GETSUBR! (MAXIMA-ERROR "No subr property for it!" X 'WRNG-TYPE-ARG))))
  147.  
  148. (DEFUN FUNTYPEP (F)
  149.   (COND ((SYMBOLP F)
  150.      (LET ((MPROPS (MGETL F '(MEXPR)))
  151.            (LPROPS #+MACLISP (GETL F '(SUBR LSUBR EXPR))
  152.                #+(OR cl NIL) (AND (FBOUNDP F)
  153.                          (LIST 'EXPR (SYMBOL-FUNCTION F)))))
  154.        (OR (IF $TRANSRUN
  155.            (OR LPROPS MPROPS)
  156.            (OR MPROPS LPROPS))
  157.            (GETL F '(OPERATORS)))))
  158.     ((consp f) ;(EQ (TYPEP F) 'LIST)
  159.      (LIST (IF (MEMQ (CAR F) '(FUNCTION LAMBDA NAMED-LAMBDA))
  160.            'EXPR
  161.            'MEXPR)
  162.            F))
  163.     ('ELSE
  164.      NIL)))
  165.  
  166. #+MACLISP
  167. (DEFUN SHIT-EQ (X Y) (= (EXAMINE (MAKNUM X)) (EXAMINE (MAKNUM Y))))
  168.  
  169. ;; For some purposes we need a more general trampoline mechanism,
  170. ;; not limited by the need to use a special variable and a
  171. ;; BIND-TRAMP$ mechanism.
  172.  
  173. ;; For now, we just need the special cases F(X), and F(X,Y) for plotting,
  174. ;; and the hackish GAPPLY$-AR$ for systems of equations.
  175.  
  176. (DEFUN MAKE-GTRAMP$ (F NARGS)
  177.   NARGS
  178.   ;; for now, ignoring the number of arguments, but we really should
  179.   ;; do this error checking.
  180.   (LET ((K (FUNTYPEP F)))
  181.     (CASE (CAR K)
  182.       ((OPERATORS)
  183.        (CONS 'OPERATORS F))
  184.       #+MACLISP
  185.       ((SUBR)
  186.        (IF (SHIT-EQ (CADR K) (GETSUBR! 'TRAMP1$-S))
  187.        (CONS 'SUBR$ (CADR K))
  188.        (CONS 'SUBR (CADR K))))
  189.       ((MEXPR EXPR LSUBR)
  190.        (CONS (CAR K) (CADR K)))
  191.       (T
  192.        (MERROR "Undefined or inscrutable function~%~M" F)))))
  193.  
  194. (DEFUN GCALL1$ (F X)
  195.   (CASE (CAR F)
  196.     #+MACLISP
  197.     ((SUBR$)
  198.      (SUBRCALL FLONUM (CDR F) X))
  199.     #+MACLISP
  200.     ((SUBR)
  201.      (FLOAT (SUBRCALL NIL (CDR F) X)))
  202.     #+MACLISP
  203.     ((LSUBR)
  204.      (FLOAT (LSUBRCALL NIL (CDR F) X)))
  205.     ((EXPR)
  206.      (FLOAT (FUNCALL (CDR F) X)))
  207.     ((MEXPR OPERATORS)
  208.      (FLOAT (MAPPLY1 (CDR F) (LIST X) NIL nil)))
  209.     (T
  210.      (MERROR "BUG: GCALL1$"))))
  211.  
  212. (DEFUN GCALL2$ (F X Y)
  213.   (CASE (CAR F)
  214.     #+MACLISP
  215.     ((SUBR$)
  216.      (SUBRCALL FLONUM (CDR F) X Y))
  217.     #+MACLISP
  218.     ((SUBR)
  219.      (FLOAT (SUBRCALL NIL (CDR F) X Y)))
  220.     #+MACLISP
  221.     ((LSUBR)
  222.      (FLOAT (LSUBRCALL NIL (CDR F) X Y)))
  223.     ((EXPR)
  224.      (FLOAT (FUNCALL (CDR F) X Y)))
  225.     ((MEXPR OPERATORS)
  226.      (FLOAT (MAPPLY (CDR F) (LIST X Y) NIL)))
  227.     (T
  228.      (MERROR "BUG: GCALL2$"))))
  229.  
  230. (DEFUN AR$+AR$ (A$ B$ C$)
  231.   (DO ((N (ARRAY-DIMENSION-N 1 A$))
  232.        (J 0 (f1+ J)))
  233.       ((= J N))
  234.     (DECLARE (FIXNUM N J))
  235.     (SETF (AREF$ A$ J) (+$ (AREF$ B$ J) (AREF$ C$ J)))))
  236.  
  237. (DEFUN AR$*S (A$ B$ S)
  238.   (DO ((N (ARRAY-DIMENSION-N 1 A$))
  239.        (J 0 (f1+ J)))
  240.       ((= J N))
  241.     (DECLARE (FIXNUM N J))
  242.     (SETF (AREF$ A$ J) (*$ (AREF$ B$ J) S))))
  243.  
  244. (DEFUN AR$GCALL2$ (AR FL X Y)
  245.   (DO ((J 0 (f1+ J))
  246.        (L FL (CDR L)))
  247.       ((NULL L))
  248.     (SETF (AREF$ AR J) (GCALL2$ (CAR L) X Y))))
  249.  
  250. (DEFUN MAKE-GTRAMP (F NARGS)
  251.   NARGS
  252.   ;; for now, ignoring the number of arguments, but we really should
  253.   ;; do this error checking.
  254.   (LET ((K (FUNTYPEP F)))
  255.     (CASE (CAR K)
  256.       ((OPERATORS)
  257.        (CONS 'OPERATORS F))
  258.       #+MACLISP
  259.       ((SUBR)
  260.        (CONS 'SUBR (CADR K)))
  261.       ((MEXPR EXPR LSUBR)
  262.        (CONS (CAR K) (CADR K)))
  263.       (T
  264.        (MERROR "Undefined or inscrutable function~%~M" F)))))
  265.  
  266. (DEFUN GCALL3 (F A1 A2 A3)
  267.   (CASE (CAR F)
  268.     #+MACLISP
  269.     ((SUBR)
  270.      (SUBRCALL T (CDR F) A1 A2 A3))
  271.     #+MACLISP
  272.     ((LSUBR)
  273.      (LSUBRCALL T (CDR F) A1 A2 A3))
  274.     ((EXPR)
  275.      (FUNCALL (CDR F)  A1 A2 A3))
  276.     ((MEXPR OPERATORS)
  277.      (MAPPLY (CDR F) (LIST A1 A2 A3) 'GCALL3))
  278.     (T
  279.      (MERROR "BUG: GCALL3"))))
  280.